!-------------------------------------------------------------LICENSE--------------------------------------------------------------!
!                                                                                                                                  !
!The MAP code is written in Fortran language for magnetohydrodynamics (MHD) calculation with the adaptive mesh refinement (AMR)    !
!and Message Passing Interface (MPI) parallelization.                                                                              !
!                                                                                                                                  !
!Copyright (C) 2012                                                                                                                !
!Ronglin Jiang                                                                                                                     !
!rljiang@ssc.net.cn                                                                                                                !
!585 Guoshoujing Road. Pudong, Shanghai, P.R.C. 201203                                                                             !
!                                                                                                                                  !
!This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License         !
!as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.             !
!                                                                                                                                  !
!This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of    !
!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.                        !
!                                                                                                                                  !
!You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software     !
!Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.                                                   !
!                                                                                                                                  !
!-------------------------------------------------------------LICENSE--------------------------------------------------------------!

!==================================================================================================================================|
subroutine neigh_exchange (base, buffer_send_x, buffer_send_y, buffer_recv_x, buffer_recv_y,                                       &
   dir, n_var, ro_flag, mx_flag, my_flag, mz_flag, bx_flag, by_flag, bz_flag, en_flag, az_flag, po_flag, fix_flag)
!==================================================================================================================================|

   use parameters
   use block_define
   implicit none

   character(1), intent(in) :: dir
   integer(4), intent(in) :: n_var
   logical(4), optional :: ro_flag, mx_flag, my_flag, mz_flag, bx_flag, by_flag, bz_flag, en_flag, az_flag, po_flag, fix_flag
   real(8), intent(inout) :: buffer_send_x(n_var, ng, ny_no_bnd, exchange_size_send_x)
   real(8), intent(inout) :: buffer_send_y(n_var, nx_block, ng, exchange_size_send_y)
   real(8), intent(inout) :: buffer_recv_x(n_var, ng, ny_no_bnd, exchange_size_recv_x)
   real(8), intent(inout) :: buffer_recv_y(n_var, nx_block, ng, exchange_size_recv_y)
   type(block), pointer, intent(in) :: base

   integer(4) :: i, j, i_cpu, i_cpu_p1, i_neigh, j_neigh, i_level, i_request, i_tmp, j_tmp, i_var, i_neigh_x, i_send_x
   integer(4) :: i_recv, i_send, cpu_index_x, cpu_index_y
   integer(4) :: n_request, n_neighs_cpu, pos_x, pos_y
   integer(4), dimension(:), allocatable :: request
   integer(4), dimension(:, :), allocatable :: request_status
   logical(4) :: fix_data_flag
   type(block), pointer :: current, neigh, neigh_x, neigh_c

!----------------------------------------------------------------------------------------------------------------------------------|
!  var send flag
!----------------------------------------------------------------------------------------------------------------------------------|
   if (n_var .le. 0) then
      write (*, *)
      write (*, *) 'Warning: no variable will be updated.'
      write (*, *)
   endif

!----------------------------------------------------------------------------------------------------------------------------------|
   if (dir .eq. 'x') then
      n_request = count (n_neighs_exchange_sendrecv_x(:, cpu_id_p1) .gt. 0) +                                                      &
                  count (n_neighs_exchange_sendrecv_x(cpu_id_p1, :) .gt. 0)
   endif
   if (dir .eq. 'y') then
      n_request = count (n_neighs_exchange_sendrecv_y(:, cpu_id_p1) .gt. 0) +                                                      &
                  count (n_neighs_exchange_sendrecv_y(cpu_id_p1, :) .gt. 0)
      if (present(fix_flag)) n_request = count (n_neighs_exchange_sendrecv_fix_y(:, cpu_id_p1) .gt. 0) +                          &
                                          count (n_neighs_exchange_sendrecv_fix_y(cpu_id_p1, :) .gt. 0)
   endif
   allocate (request(n_request * 2), request_status(mpi_status_size, n_request * 2))

!----------------------------------------------------------------------------------------------------------------------------------|
!  collect information for sending data
!----------------------------------------------------------------------------------------------------------------------------------|
   cpu_index_x = 1
   cpu_index_y = 1
   do i_cpu = 0, cpu_number - 1

      if (i_cpu .eq. cpu_id) cycle
      i_cpu_p1 = i_cpu + 1

      if (dir .eq. 'x') then
         n_neighs_cpu = n_neighs_exchange_sendrecv_x(i_cpu_p1, cpu_id_p1)
         do i_send = 1, n_neighs_cpu
            i_level = 1
            current => base
            do while (neighs_exchange_info_send_x(i_level * 2 - 1, i_send, i_cpu_p1) .ne. 0)
               pos_x = neighs_exchange_info_send_x(i_level * 2 - 1, i_send, i_cpu_p1)
               pos_y = neighs_exchange_info_send_x(i_level * 2, i_send, i_cpu_p1)
               current => current%child(pos_x, pos_y)%pblock
               i_level = i_level + 1
               if (i_level .gt. n_levels) exit
            enddo

            i_neigh = neighs_exchange_info_send_x(n_d_l + 1, i_send, i_cpu_p1)
            if (i_neigh .eq. 1) i_neigh = nx_no_bnd
            if (i_neigh .eq. -1) i_neigh = ng

            do j = 1, ny_no_bnd
               j_tmp = j + ng
               do i = 1, ng
                  i_tmp = i + i_neigh
                  i_var = 0
                  if (present(ro_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%ro(i_tmp, j_tmp)
                  endif
                  if (present(mx_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%mx(i_tmp, j_tmp)
                  endif
                  if (present(my_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%my(i_tmp, j_tmp)
                  endif
                  if (present(mz_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%mz(i_tmp, j_tmp)
                  endif
                  if (present(bx_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%bx(i_tmp, j_tmp)
                  endif
                  if (present(by_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%by(i_tmp, j_tmp)
                  endif
                  if (present(bz_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%bz(i_tmp, j_tmp)
                  endif
                  if (present(en_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%en(i_tmp, j_tmp)
                  endif
                  if (present(az_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%az(i_tmp, j_tmp)
                  endif
                  if (present(po_flag)) then
                     i_var = i_var + 1
                     buffer_send_x(i_var, i, j, cpu_index_x) = current%po(i_tmp, j_tmp)
                  endif
               enddo
            enddo
            cpu_index_x = cpu_index_x + 1
         enddo
      endif

      if (dir .eq. 'y') then
         i_send_x = 0
         n_neighs_cpu = n_neighs_exchange_sendrecv_y(i_cpu_p1, cpu_id_p1)
         do i_send = 1, n_neighs_cpu
            i_level = 1
            current => base
            do while (neighs_exchange_info_send_y(i_level * 2 - 1, i_send, i_cpu_p1) .ne. 0)
               pos_x = neighs_exchange_info_send_y(i_level * 2 - 1, i_send, i_cpu_p1)
               pos_y = neighs_exchange_info_send_y(i_level * 2, i_send, i_cpu_p1)
               current => current%child(pos_x, pos_y)%pblock
               i_level = i_level + 1
               if (i_level .gt. n_levels) exit
            enddo

            j_neigh = neighs_exchange_info_send_y(n_d_l + 1, i_send, i_cpu_p1)
!----------------------------------------------------------------------------------------------------------------------------------|
!           fix the data exchage in y direction because of the shareblocks
!----------------------------------------------------------------------------------------------------------------------------------|
            if (present(fix_flag)) then
               fix_data_flag = .false.
               do i_neigh_x = -1, 1, 2
                  neigh_x => current%neigh(i_neigh_x, 0)%pblock
                  neigh_c => current%neigh(i_neigh_x, j_neigh)%pblock
                  if (associated(neigh_x) .and. associated(neigh_c)) then
                     if (neigh_x%lv .eq. current%lv - 1 .and. neigh_c%lv .eq. current%lv) fix_data_flag = .true.
                  endif
               enddo
               if (.not. fix_data_flag) cycle
               i_send_x = i_send_x + 1
               neighs_exchange_info_send_fix_y(:, i_send_x, i_cpu_p1) = neighs_exchange_info_send_y(:, i_send, i_cpu_p1)
            endif

            if (j_neigh .eq. 1) j_neigh = ny_no_bnd
            if (j_neigh .eq. -1) j_neigh = ng

            do j = 1, ng
               j_tmp = j + j_neigh
               do i = 1, nx_block
                  i_var = 0
                  if (present(ro_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%ro(i, j_tmp)
                  endif
                  if (present(mx_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%mx(i, j_tmp)
                  endif
                  if (present(my_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%my(i, j_tmp)
                  endif
                  if (present(mz_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%mz(i, j_tmp)
                  endif
                  if (present(bx_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%bx(i, j_tmp)
                  endif
                  if (present(by_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%by(i, j_tmp)
                  endif
                  if (present(bz_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%bz(i, j_tmp)
                  endif
                  if (present(en_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%en(i, j_tmp)
                  endif
                  if (present(az_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%az(i, j_tmp)
                  endif
                  if (present(po_flag)) then
                     i_var = i_var + 1
                     buffer_send_y(i_var, i, j, cpu_index_y) = current%po(i, j_tmp)
                  endif
               enddo
            enddo
            cpu_index_y = cpu_index_y + 1
         enddo
      endif

   enddo

!----------------------------------------------------------------------------------------------------------------------------------|
!  send data to other cpu
!----------------------------------------------------------------------------------------------------------------------------------|
   i_request = 0
   cpu_index_x = 1
   cpu_index_y = 1
   do i_cpu = 0, cpu_number - 1

      if (cpu_id .eq. i_cpu) cycle
      i_cpu_p1 = i_cpu + 1

      if (dir .eq. 'x') then
         n_neighs_cpu = n_neighs_exchange_sendrecv_x(i_cpu_p1, cpu_id_p1)
         if (n_neighs_cpu .ne. 0) then
            i_request = i_request + 1
            call mpi_isend(neighs_exchange_info_send_x(:, :, i_cpu_p1), (n_d_l + 1) * n_neighs_cpu,                                &
               mpi_integer4, i_cpu, tag_int + 5, mpi_comm_world, request(i_request), error)
            i_request = i_request + 1
            call mpi_isend(buffer_send_x(:, :, :, cpu_index_x), n_var * ng * ny_no_bnd * n_neighs_cpu,                             &
               mpi_real8, i_cpu, tag_var + 5, mpi_comm_world, request(i_request), error)
            cpu_index_x = cpu_index_x + n_neighs_cpu
         endif
      endif

      if (dir .eq. 'y') then
         n_neighs_cpu = n_neighs_exchange_sendrecv_y(i_cpu_p1, cpu_id_p1)
!----------------------------------------------------------------------------------------------------------------------------------|
!        send the fixed data in y direction because of the shareblocks
!----------------------------------------------------------------------------------------------------------------------------------|
         if (present(fix_flag)) n_neighs_cpu = n_neighs_exchange_sendrecv_fix_y(i_cpu_p1, cpu_id_p1)
         if (n_neighs_cpu .ne. 0) then
            i_request = i_request + 1
            if (.not. present(fix_flag)) call mpi_isend(neighs_exchange_info_send_y(:, :, i_cpu_p1), (n_d_l + 1) * n_neighs_cpu,   &
               mpi_integer4, i_cpu, tag_int + 6, mpi_comm_world, request(i_request), error)
            if (present(fix_flag)) call mpi_isend(neighs_exchange_info_send_fix_y(:, :, i_cpu_p1), (n_d_l + 1) * n_neighs_cpu,     &
               mpi_integer4, i_cpu, tag_int + 6, mpi_comm_world, request(i_request), error)
            i_request = i_request + 1
            call mpi_isend(buffer_send_y(:, :, :, cpu_index_y), n_var * ng * nx_block * n_neighs_cpu,                              &
               mpi_real8, i_cpu, tag_var + 6, mpi_comm_world, request(i_request), error)
            cpu_index_y = cpu_index_y + n_neighs_cpu
         endif
      endif
   enddo

!----------------------------------------------------------------------------------------------------------------------------------|
!  receive data from other cpu
!----------------------------------------------------------------------------------------------------------------------------------|
   cpu_index_x = 1
   cpu_index_y = 1
   do i_cpu = 0, cpu_number - 1

      if (cpu_id .eq. i_cpu) cycle
      i_cpu_p1 = i_cpu + 1

      if (dir .eq. 'x') then
         n_neighs_cpu = n_neighs_exchange_sendrecv_x(cpu_id_p1, i_cpu_p1)
         if (n_neighs_cpu .ne. 0) then
            i_request = i_request + 1
            call mpi_irecv(neighs_exchange_info_recv_x(:, :, i_cpu_p1), (n_d_l + 1) * n_neighs_cpu,                                &
               mpi_integer4, i_cpu, tag_int + 5, mpi_comm_world, request(i_request), error)
            i_request = i_request + 1
            call mpi_irecv(buffer_recv_x(:, :, :, cpu_index_x), n_var * ng * ny_no_bnd * n_neighs_cpu,                             &
               mpi_real8, i_cpu, tag_var + 5, mpi_comm_world, request(i_request), error)
            cpu_index_x = cpu_index_x + n_neighs_cpu
         endif
      endif

      if (dir .eq. 'y') then
         n_neighs_cpu = n_neighs_exchange_sendrecv_y(cpu_id_p1, i_cpu_p1)
         if (present(fix_flag)) n_neighs_cpu = n_neighs_exchange_sendrecv_fix_y(cpu_id_p1, i_cpu_p1)
         if (n_neighs_cpu .ne. 0) then
            i_request = i_request + 1
            call mpi_irecv(neighs_exchange_info_recv_y(:, :, i_cpu_p1), (n_d_l + 1) * n_neighs_cpu,                                &
               mpi_integer4, i_cpu, tag_int + 6, mpi_comm_world, request(i_request), error)
            i_request = i_request + 1
            call mpi_irecv(buffer_recv_y(:, :, :, cpu_index_y), n_var * ng * nx_block * n_neighs_cpu,                              &
               mpi_real8, i_cpu, tag_var + 6, mpi_comm_world, request(i_request), error)
            cpu_index_y = cpu_index_y + n_neighs_cpu
         endif
      endif

   enddo

!----------------------------------------------------------------------------------------------------------------------------------|
!  waiting for mpi communication
!----------------------------------------------------------------------------------------------------------------------------------|
   call mpi_waitall (size (request), request, request_status, error)

!----------------------------------------------------------------------------------------------------------------------------------|
!  update neigh blocks
!----------------------------------------------------------------------------------------------------------------------------------|
   cpu_index_x = 1
   cpu_index_y = 1
   do i_cpu = 0, cpu_number - 1

      if (i_cpu .eq. cpu_id) cycle
      i_cpu_p1 = i_cpu + 1

      if (dir .eq. 'x') then
         n_neighs_cpu = n_neighs_exchange_sendrecv_x(cpu_id_p1, i_cpu_p1)
         do i_recv = 1, n_neighs_cpu
            i_level = 1
            current => base
            do while (neighs_exchange_info_recv_x(i_level * 2 - 1, i_recv, i_cpu_p1) .ne. 0)
               pos_x = neighs_exchange_info_recv_x(i_level * 2 - 1, i_recv, i_cpu_p1)
               pos_y = neighs_exchange_info_recv_x(i_level * 2, i_recv, i_cpu_p1)
               current => current%child(pos_x, pos_y)%pblock
               i_level = i_level + 1
               if (i_level .gt. n_levels) exit
            enddo

            i_neigh = neighs_exchange_info_recv_x(n_d_l + 1, i_recv, i_cpu_p1)
            neigh => current%neigh(i_neigh, 0)%pblock
            if (i_neigh .eq. 1) i_neigh = 0
            if (i_neigh .eq. -1) i_neigh = nx_no_bnd + ng

            do j = 1, ny_no_bnd
               j_tmp = j + ng
               do i = 1, ng
                  i_tmp = i + i_neigh
                  i_var = 0
                  if (present(ro_flag)) then
                     i_var = i_var + 1
                     neigh%ro(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(mx_flag)) then
                     i_var = i_var + 1
                     neigh%mx(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(my_flag)) then
                     i_var = i_var + 1
                     neigh%my(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(mz_flag)) then
                     i_var = i_var + 1
                     neigh%mz(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(bx_flag)) then
                     i_var = i_var + 1
                     neigh%bx(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(by_flag)) then
                     i_var = i_var + 1
                     neigh%by(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(bz_flag)) then
                     i_var = i_var + 1
                     neigh%bz(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(en_flag)) then
                     i_var = i_var + 1
                     neigh%en(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(az_flag)) then
                     i_var = i_var + 1
                     neigh%az(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
                  if (present(po_flag)) then
                     i_var = i_var + 1
                     neigh%po(i_tmp, j_tmp) = buffer_recv_x(i_var, i, j, cpu_index_x)
                  endif
               enddo
            enddo
            cpu_index_x = cpu_index_x + 1
         enddo
      endif

      if (dir .eq. 'y') then
         n_neighs_cpu = n_neighs_exchange_sendrecv_y(cpu_id_p1, i_cpu_p1)
         if (present(fix_flag)) n_neighs_cpu = n_neighs_exchange_sendrecv_fix_y(cpu_id_p1, i_cpu_p1)
         do i_recv = 1, n_neighs_cpu
            i_level = 1
            current => base
            do while (neighs_exchange_info_recv_y(i_level * 2 - 1, i_recv, i_cpu_p1) .ne. 0)
               pos_x = neighs_exchange_info_recv_y(i_level * 2 - 1, i_recv, i_cpu_p1)
               pos_y = neighs_exchange_info_recv_y(i_level * 2, i_recv, i_cpu_p1)
               current => current%child(pos_x, pos_y)%pblock
               i_level = i_level + 1
               if (i_level .gt. n_levels) exit
            enddo

            j_neigh = neighs_exchange_info_recv_y(n_d_l + 1, i_recv, i_cpu_p1)
            neigh => current%neigh(0, j_neigh)%pblock
            if (j_neigh .eq. 1) j_neigh = 0
            if (j_neigh .eq. -1) j_neigh = ny_no_bnd + ng
            do j = 1, ng
               j_tmp = j + j_neigh
               do i = 1, nx_block
                  i_var = 0
                  if (present(ro_flag)) then
                     i_var = i_var + 1
                     neigh%ro(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(mx_flag)) then
                     i_var = i_var + 1
                     neigh%mx(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(my_flag)) then
                     i_var = i_var + 1
                     neigh%my(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(mz_flag)) then
                     i_var = i_var + 1
                     neigh%mz(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(bx_flag)) then
                     i_var = i_var + 1
                     neigh%bx(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(by_flag)) then
                     i_var = i_var + 1
                     neigh%by(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(bz_flag)) then
                     i_var = i_var + 1
                     neigh%bz(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(en_flag)) then
                     i_var = i_var + 1
                     neigh%en(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(az_flag)) then
                     i_var = i_var + 1
                     neigh%az(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
                  if (present(po_flag)) then
                     i_var = i_var + 1
                     neigh%po(i, j_tmp) = buffer_recv_y(i_var, i, j, cpu_index_y)
                  endif
               enddo
            enddo
            cpu_index_y = cpu_index_y + 1
         enddo
      endif

   enddo

   deallocate (request, request_status)

!----------------------------------------------------------------------------------------------------------------------------------|
   return
end subroutine neigh_exchange
